(in-package :procemu)

(defmacro define-instruction-constructor (instruction args)
  `(setf (get ,(intern (symbol-name instruction) :keyword)
	      'instruction-constructor)
         #'(lambda ,args
	     (let ((object (make-instance ',instruction)))
	       ,@(loop for arg in args
		       collect `(setf (slot-value object ',arg) ,arg))
	       object))))

(define-instruction-constructor add (destination source))
(define-instruction-constructor sub (destination source))
(define-instruction-constructor mul (destination source))
(define-instruction-constructor div (destination source))

(define-instruction-constructor mov (destination source))

(define-instruction-constructor jmp (destination))

(define-instruction-constructor push (place))
(define-instruction-constructor pop (place))


(defun make-stack-vector ()
  (make-array 0
	      :adjustable t
	      :fill-pointer t))

(defvar *push-to* nil
  "Vector which is pushed to by WITH-ASM. For internal use only.")

(defvar *top-level* t
  "Is this the top-level WITH-ASM?")

(defvar *current-line* 0
  "What line are we on, not counting non-instructions?")

(defvar *labels-hash* (make-hash-table)
  "Hash table mapping labels to their locations in the source code")

(defun normalize-instruction-argument (form)
  (typecase form
    (symbol (if (keywordp form)
		form
		(let ((string (symbol-name form)))
		  (if (equalp (elt string 0) #\R)
		      (handler-case (cons 'register
					  (parse-integer string :start 1))
			(parse-error () (error "Not a register: ~S" form)))
		      (error "Not a register: ~S" form)))))
    (number form)
    (list (destructuring-bind (type locator) form
	    (cons type locator)))))

(defun remove-symbol-references (instruction)
  (if (typep instruction 'jump-instruction)
      (multiple-value-bind (location found-p)
	  (gethash (destination instruction) *labels-hash*)
	(if found-p
	    (setf (destination instruction)
		  location)
	    (error "Label not found: ~S"
		   (destination instruction)))))
  instruction)

(defmacro with-asm ((&key execute) &body body)
  (let ((push-to (or *push-to* (make-stack-vector))))
    (dolist (line body)
      (cond
	((and (listp line)		; Instruction
	      (keywordp (car line)))
	 (vector-push-extend (apply (get (car line)
					 'instruction-constructor)
				    (mapcar #'normalize-instruction-argument
					    (cdr line)))
			     push-to))
	((keywordp line)		; Label
	 (setf (gethash line *labels-hash*)
	       *current-line*)
	 ;; This label doesn't count as a line
	 (decf *current-line*))
	(t (let ((*push-to* push-to)	; Lisp code
		 (*top-level* nil))
	     (eval line)
	     (decf *current-line*))))
      (incf *current-line*))
    (when *top-level*			; Clean up
      (map-into push-to #'remove-symbol-references push-to)
      (setf *current-line* 0)
      (setf *labels-hash* (make-hash-table)))
    (if execute
	`(let ((cpu (make-instance 'cpu)))
	  (run cpu ,push-to)
	  cpu)
	push-to)))

;(registers (with-asm (:execute t)
;             (:mov r1 38)
;             (:mov r2 2)
;             (:add r1 r2)
;             (:mov r0 r1)
;             (:add r0 r2)))
;
(defun swapmem (x y)
  "Swap two memory locations"
  (eval `(with-asm ()
          (:push r0)
          (:mov r0 (memory ,x))
          (:mov (memory ,x) (memory ,y))
          (:mov (memory ,y) r0)
          (:pop r0))))
;
;(with-asm ()
;  (:mov (memory 0) 111)
;  (:mov (memory 1) 222)
;  (swapmem 0 1))       
;
;(let ((cpu (with-asm (:execute t)
;             (:mov (memory 0) 111)
;             (:mov (memory 1) 222)
;             (swapmem 0 1))))
;  (values (registers cpu)
;          (subseq (memory-bank cpu) 0 2)))
;
;(with-asm ()
;  (:mov r1 38)
;  (:mov r2 2)
;  (:add r1 r2)
;  (print 'hello)
;  (:mov r0 r1)
;  :label
;  (:add r0 r2))
;
;(with-asm ()
;  (with-asm ()
;    (:mov r1 38)
;    :foo
;    (:mov r2 2))
;  (:add r1 r2)
;  (print 'hello)
;  (:mov r0 r1)
;  :label
;  (:add r0 r2))
;
;(registers (with-asm (:execute t)
;             (:mov r0 42)
;             (:jmp :done)
;             (:add r0 666)
;             :done))
